home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / shells.l < prev    next >
Lisp/Scheme  |  1989-07-12  |  35KB  |  1,023 lines
  1. ;;; -*- Mode:Lisp; Package:CLUEI; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1989 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package 'cluei :use '(lisp xlib))
  20.  
  21. (export
  22.   '(
  23.     override-shell
  24.     shell
  25.     shell-owner
  26.     sm-client-host
  27.     sm-command
  28.     top-level-session
  29.     top-level-shell
  30.     transient-shell
  31.     with-wm-properties
  32.     with-wm-properties 
  33.     wm-base-height
  34.     wm-base-width
  35.     wm-colormap-owners
  36.     wm-delta-height
  37.     wm-delta-width
  38.     wm-gravity
  39.     wm-group
  40.     wm-icon
  41.     wm-icon-mask
  42.     wm-icon-title
  43.     wm-icon-x
  44.     wm-icon-y
  45.     wm-initial-state
  46.     wm-keyboard-input
  47.     wm-max-aspect
  48.     wm-max-height
  49.     wm-max-width
  50.     wm-message 
  51.     wm-message-protocol
  52.     wm-message-timestamp
  53.     wm-min-aspect
  54.     wm-min-height
  55.     wm-min-width
  56.     wm-protocols
  57.     wm-shell    
  58.     wm-title
  59.     wm-user-specified-position-p
  60.     wm-user-specified-size-p
  61.     )
  62.   'cluei)
  63.  
  64.  
  65.  
  66. ;;;----------------------------------------------------------------------------+
  67. ;;;                                                                            |
  68. ;;;                       Shell                                    |
  69. ;;;                                                                            |
  70. ;;;----------------------------------------------------------------------------+
  71.  
  72.  
  73. (defcontact shell (composite)
  74.   ((state        :type     (member :withdrawn :iconic :mapped)
  75.          :accessor contact-state)
  76.    
  77.    (owner        :type     composite
  78.          :reader   shell-owner))
  79.   (:resources
  80.     (state       :type     (member :withdrawn :iconic :mapped)
  81.          :initform (shell-default-state instance)))
  82.   
  83.   (:documentation
  84.     "Base class for all shell contacts."))
  85.  
  86.  
  87.  
  88. ;;;----------------------------------------------------------------------------+
  89. ;;;                                                                            |
  90. ;;;                  Shell: State management                           |
  91. ;;;                                                                            |
  92. ;;;----------------------------------------------------------------------------+
  93.  
  94. (defun shell-default-state (shell)
  95.   ;; WARNING: assumes that the parent slot still contains the owner and
  96.   ;; has not yet been reset to the root!
  97.  
  98.   ;; Is this a root shell?
  99.   (if (eq (contact-parent shell) (contact-root shell))
  100.       :mapped
  101.       :withdrawn))
  102.  
  103. (defmethod initial-state-transition ((shell shell))
  104.   "Return the old-state/new-state for the initial (setf contact-state) after CONTACT
  105.    is realized. Return nil if (setf contact-state) need not be called, i.e. no
  106.    initial state transition is necessary."
  107.   (with-slots (state) shell
  108.     (unless (eq :withdrawn state)
  109.       (values :withdrawn state))))
  110.  
  111. (defmethod (setf contact-state) (new-state (shell shell))
  112.   (check-type new-state (member :withdrawn :iconic :mapped))    
  113.   
  114.   (with-slots (parent display state) shell
  115.     (unless (eq state new-state)
  116.       (let ((old-state state))
  117.     
  118.     (setf state new-state)
  119.     
  120.     (if (realized-p shell)
  121.         ;; Change state now -- don't send side-effect requests if inside
  122.         ;; without-requests wrapper.
  123.         (case new-state
  124.           (:mapped    (apply-callback shell :map)
  125.               (unless (eq *contact-notified* shell)
  126.                 (map-window shell)))
  127.           
  128.           (:iconic    (if (eq old-state :withdrawn)                 
  129.                   (progn
  130.                 (unless (eq :iconic (wm-initial-state shell))
  131.                   (setf (wm-initial-state shell) :iconic))
  132.                 (unless (eq *contact-notified* shell)
  133.                   (map-window shell)))
  134.                   
  135.                   (progn
  136.                 (unless (eq *contact-notified* shell)
  137.                   (send-event parent
  138.                           :client-message
  139.                           #.(make-event-mask)
  140.                           :event-window parent
  141.                           :type :wm_change_state
  142.                           :format 32
  143.                           :data '(3)    ;Crock: this should be an xlib defconstant
  144.                           ))    
  145.                 (apply-callback shell :unmap))))
  146.           
  147.           (:withdrawn (unless (eq *contact-notified* shell)
  148.                 (unmap-window shell)
  149.                 (send-event parent
  150.                     :unmap-notify
  151.                     #.(make-event-mask :substructure-redirect :substructure-notify)
  152.                     :event-window parent
  153.                     :window shell
  154.                     :configure-p nil))
  155.               (apply-callback shell :unmap)))
  156.         
  157.         ;; Not realized, let UPDATE-STATE do the work
  158.         (setf (display-update-flag display) t)))))
  159.   new-state)
  160.  
  161.  
  162.  
  163. ;;;----------------------------------------------------------------------------+
  164. ;;;                                                                            |
  165. ;;;                Shell: Geometry Management                          |
  166. ;;;                                                                            |
  167. ;;;----------------------------------------------------------------------------+
  168.  
  169. (defmethod add-to-parent ((self shell))
  170.   (with-slots (parent owner) self
  171.     (let ((root (contact-root self)))
  172.       
  173.       ;; Initialize shell owner
  174.       (setf owner parent)
  175.       (with-slots (shells) owner
  176.     (unless (member self shells :test #'eq)
  177.         (setf shells (nconc shells (cons self nil)))))
  178.  
  179.       ;; A shell is always a child of its root
  180.       (setf parent root)
  181.       (add-child root self))))
  182.  
  183. (defmethod contact-resource-parent ((shell shell))
  184.   (slot-value shell 'owner))
  185.  
  186. (defmethod add-child :before ((shell shell) child &key)  
  187.   (with-slots (children) shell
  188.     (when children
  189.       (error "~s already has child ~s; cannot add child ~s."
  190.          shell
  191.          (first children)
  192.          child))))
  193.  
  194. (defmethod manage-geometry ((parent shell) child x y width height border-width &key) 
  195.   (declare (type contact child)
  196.        (type (or null int16) x y)
  197.        (type (or null card16) width height border-width)
  198.        (values success-p x y width height border-width))  
  199.   
  200.   (let* ((child-bw     (or border-width (contact-border-width child)))
  201.      (required-pos (- child-bw)))
  202.     
  203.     (with-slots ((parent-width width) (parent-height height)) parent 
  204.       (multiple-value-bind (size-approved-p approved-width approved-height)
  205.       
  206.       (if (and (realized-p parent)
  207.            (or (setf width  (unless (eq width  (contact-width child))  width))
  208.                (setf height (unless (eq height (contact-height child)) height))))
  209.           
  210.           ;; Request corresponding change in top-level shell size
  211.           ;; Since shell is top-level, changed size is effected immediately
  212.           (values
  213.         (change-geometry parent :width width :height height)
  214.         parent-width
  215.         parent-height)
  216.           
  217.           ;; Unrealized shell approves and adopts change immediately
  218.           (values
  219.         t
  220.         (setf parent-width  (or width  (contact-width child)))
  221.         (setf parent-height (or height (contact-height child)))))
  222.  
  223.     ;; Shell child always positioned so that its borders are invisible.
  224.     (values
  225.       (and size-approved-p
  226.            (or (null x) (= x required-pos))
  227.            (or (null y) (= y required-pos)))    
  228.       required-pos
  229.       required-pos
  230.       approved-width   
  231.       approved-height
  232.       child-bw)))))
  233.  
  234.  
  235. (defmethod manage-priority ((parent shell) child priority sibling &key)  
  236.   (declare (type (member :above :below :top-if :bottom-if :opposite) priority)
  237.        (type (or null contact) sibling)
  238.        (values success-p priority sibling))
  239.   (declare (ignore child priority sibling))
  240.   ;; Never approved since shell has only one child
  241.   nil)
  242.  
  243. (defmethod change-layout ((shell shell) &optional newly-managed)
  244.   (declare (ignore newly-managed))
  245.   (with-slots (children width height) shell
  246.     (when children
  247.       ;; Shell assumes size of its content
  248.       (let* ((content        (first children))
  249.          (content-width  (contact-width content))
  250.          (content-height (contact-height content)))
  251.     
  252.     (if (realized-p shell)
  253.         ;; Negotiate with window mgr
  254.         (change-geometry shell
  255.                  :width  content-width
  256.                  :height content-height)
  257.         
  258.         ;; Else change size of unrealized shell immediately
  259.         (setf width  content-width
  260.           height content-height))
  261.     
  262.     ;; Position content to hide content border
  263.     (change-geometry content :accept-p t)))))
  264.  
  265.  
  266. (defmethod resize :after ((shell shell) width height border-width)
  267.   (declare (ignore border-width)) 
  268.   (with-slots (children) shell
  269.     (let ((content (first children)))
  270.       (when content
  271.     ;; Force content to have same size
  272.     (resize content width height
  273.         (contact-border-width content))))))
  274.  
  275.  
  276. ;;;----------------------------------------------------------------------------+
  277. ;;;                                                                            |
  278. ;;;                   Shell: Event Handling                            |
  279. ;;;                                                                            |
  280. ;;;----------------------------------------------------------------------------+
  281.  
  282. (defmethod handle-event :before ((shell shell) (event event))
  283.   (with-slots (key) event
  284.     (case key
  285.       (:configure-notify
  286.        ;; Update geometry slots to reflect reality
  287.        (with-slots ((new-x            x)
  288.             (new-y            y)
  289.             (new-width        width)
  290.             (new-height       height)
  291.             (new-border-width border-width)) event
  292.      (with-slots (x y width height border-width) shell       
  293.        (without-requests shell        ;no configure request side-effect
  294.          ;; Use move/resize protocol so that any auxilliary methods will fire
  295.          ;; Call only if geometry actually changed 
  296.          (unless (and (= x new-x) (= y new-y))
  297.            (move shell new-x new-y))
  298.          (unless (and (= width new-width) (= height new-height)
  299.               (= border-width new-border-width))
  300.            (resize shell new-width new-height new-border-width))))))
  301.       
  302.       (:map-notify
  303.        ;; Update state to reflect reality
  304.        (without-requests shell
  305.      (setf (contact-state shell) :mapped)))
  306.       
  307.       (:unmap-notify
  308.        ;; Update state to reflect reality
  309.        (without-requests shell
  310.      (setf (contact-state shell) :iconic))))))
  311.  
  312.  
  313.  
  314. ;;;----------------------------------------------------------------------------+
  315. ;;;                                                                            |
  316. ;;;                  Override Shell                                |
  317. ;;;                                                                            |
  318. ;;;----------------------------------------------------------------------------+
  319.  
  320. (defcontact override-shell (shell)
  321.   ()
  322.   (:resources
  323.     (override-redirect :initform :on))
  324.   (:documentation
  325.     "Base class for shells which override the window manager."))
  326.  
  327. (defmethod (setf contact-state) :around (new-state (shell override-shell))
  328.   ;; :iconic is equivalent to :withdrawn for override-shell
  329.   (call-next-method
  330.     (if (eq :iconic new-state) :withdrawn new-state)
  331.     shell))
  332.  
  333.  
  334. ;;;----------------------------------------------------------------------------+
  335. ;;;                                                                            |
  336. ;;;            Batching window manager property changes                   |
  337. ;;;                                                                            |
  338. ;;;----------------------------------------------------------------------------+
  339.  
  340. (defmacro wm-properties-changed (shell &optional default)
  341.   "Return list of changed window manager properties for the SHELL."
  342.   `(getf (window-plist ,shell) 'wm-properties-changed ,default))
  343.  
  344. (defmacro wm-changing-properties-p (shell)
  345.   "Return true if currently batching changes to window manager properties of the SHELL."
  346.   `(not (eq :undefined (wm-properties-changed ,shell :undefined))))
  347.  
  348. (defsetf wm-changing-properties-p (shell) (value)
  349.   "Turn off/on batching of changes to window manager properties of the SHELL."
  350.   `(if ,value
  351.        (setf (wm-properties-changed ,shell) nil)
  352.        (remf (window-plist ,shell) 'wm-properties-changed)))
  353.  
  354. (defmacro with-wm-properties ((shell) &body body)
  355.   "Batch all changes to window manager properties of the SHELL into one request
  356. after the BODY." 
  357.   `(progn
  358.      (setf (wm-changing-properties-p ,shell) t)
  359.      ,@body
  360.      (when (wm-properties-changed ,shell)
  361.        (apply #'wm-batch-change-properties (wm-properties-changed ,shell)))
  362.      (setf (wm-changing-properties-p ,shell) nil)))
  363.  
  364.  
  365. (defmacro define-wm-batch-change-properties ()
  366.   "Generate WM-BATCH-CHANGE-PROPERTIES function definition."
  367.   `(defun wm-batch-change-properties (shell &rest properties)
  368.      "Change the properties which control window manager interaction."
  369.      ,@(let (code)
  370.      (dolist (p
  371.            '(
  372.              ;; class, transient-for properties not included because
  373.              ;; they should only be changed during initialization
  374.              
  375.              client-machine
  376.              colormap-windows
  377.              command
  378.              hints
  379.              icon-name
  380.              name
  381.              normal-hints
  382.              protocols
  383.              )
  384.            code)
  385.        (let ((accessor (intern (format nil "WM-CHANGE-~a" (symbol-name p)) 'cluei)))
  386.          (push
  387.            `(when (member ',p properties :test #'eq)
  388.           (,accessor shell))
  389.            code))))))
  390.  
  391. (define-wm-batch-change-properties)
  392.  
  393.  
  394. ;;;----------------------------------------------------------------------------+
  395. ;;;                                                                            |
  396. ;;;                  Window Manager Shell                             |
  397. ;;;                                                                            |
  398. ;;;----------------------------------------------------------------------------+
  399.  
  400. (defcontact wm-shell (shell)
  401.   ((hints                :type     (OR null wm-hints)
  402.              :initform nil 
  403.              :initarg  :hints
  404.              :accessor shell-hints)
  405.    
  406.    (normal-hints         :type     (OR null wm-size-hints)
  407.              :initform nil 
  408.              :initarg  :normal-hints
  409.              :accessor shell-normal-hints)
  410.    
  411.    (protocols            :type     (OR null list) 
  412.              :initform nil 
  413.              :initarg  :protocols
  414.              :accessor wm-protocols)
  415.    
  416.    (title                :type     (OR null stringable)
  417.              :initform nil 
  418.              :initarg  :wm-title
  419.              :accessor wm-title))
  420.  
  421.   (:resources
  422.     (event-mask :initform #.(make-event-mask :structure-notify)))
  423.     
  424.   (:documentation
  425.     "Base class for shells which interact with the window manager."))
  426.  
  427.  
  428. (defmethod realize :after ((shell wm-shell)) 
  429.   (wm-change-class        shell)
  430.   (wm-change-hints        shell)
  431.   (wm-change-name         shell)
  432.   (wm-change-normal-hints shell)
  433.   (wm-change-protocols    shell))
  434.  
  435.  
  436.  
  437.  
  438. ;;;----------------------------------------------------------------------------+
  439. ;;;                                                                            |
  440. ;;;                  WM_PROTOCOLS accessors                            |
  441. ;;;                                                                            |
  442. ;;;----------------------------------------------------------------------------+
  443.  
  444.  
  445. (defmethod wm-change-protocols ((shell wm-shell))
  446.   "Send a request to change the WM_PROTOCOLS property for the SHELL."
  447.   (with-slots (protocols) shell
  448.     (if protocols
  449.     (change-property shell :wm_protocols
  450.              protocols
  451.              :atom
  452.              32)
  453.     (delete-property shell :wm_protocols))))
  454.  
  455. (defmethod (setf wm-protocols) :after (new-protocols (shell wm-shell))
  456.   (declare (ignore new-protocols))
  457.   (if (wm-changing-properties-p shell)
  458.       (adjoin 'protocols (wm-properties-changed shell))
  459.       (wm-change-protocols shell)))
  460.  
  461.  
  462. ;;;----------------------------------------------------------------------------+
  463. ;;;                                                                            |
  464. ;;;                     WM_NAME accessors                              |
  465. ;;;                                                                            |
  466. ;;;----------------------------------------------------------------------------+
  467.  
  468.  
  469. (defmethod wm-change-name ((shell wm-shell))
  470.   "Send a request to change the WM_NAME property for the SHELL."
  471.   (with-slots (title name) shell
  472.     (setf (wm-name shell) (or title name))))
  473.  
  474. (defmethod (setf wm-title) :after (new-title (shell wm-shell))
  475.   (declare (ignore new-title))
  476.   (if (wm-changing-properties-p shell)
  477.       (adjoin 'name (wm-properties-changed shell))
  478.       (wm-change-name shell)))
  479.  
  480.  
  481. ;;;----------------------------------------------------------------------------+
  482. ;;;                                                                            |
  483. ;;;                    WM_CLASS accessors                              |
  484. ;;;                                                                            |
  485. ;;;----------------------------------------------------------------------------+
  486.  
  487. ;; This should only be called during initialization
  488. (defmethod wm-change-class ((shell wm-shell))
  489.   "Send a request to change the WM_CLASS property for the SHELL."
  490.   (let ((d (contact-display shell)))
  491.     (set-wm-class shell
  492.           (display-name d)
  493.           (display-class d))))
  494.                 
  495.  
  496. ;;;----------------------------------------------------------------------------+
  497. ;;;                                                                            |
  498. ;;;                 WM_NORMAL_HINTS accessors                          |
  499. ;;;                                                                            |
  500. ;;;----------------------------------------------------------------------------+
  501.  
  502. (defmethod (setf shell-normal-hints) :after (new-normal-hints (shell wm-shell))
  503.   (declare (ignore new-normal-hints))
  504.   (wm-change-normal-hints shell))
  505.  
  506. (defmethod wm-change-normal-hints ((shell wm-shell))
  507.   "Send a request to change the WM_NORMAL_HINTS property for the SHELL."
  508.   (with-slots (normal-hints) shell
  509.     (if normal-hints
  510.     (setf (wm-normal-hints shell) normal-hints)
  511.     (delete-property shell :wm_normal_hints))))
  512.  
  513. (defun wm-update-normal-hints (shell)
  514.   "Record an update to the WM_NORMAL_HINTS property for the SHELL."
  515.   (if (wm-changing-properties-p shell)
  516.       (adjoin 'normal-hints (wm-properties-changed shell))
  517.       (wm-change-normal-hints shell)))
  518.  
  519. (defmethod wm-user-specified-size-p ((shell wm-shell))
  520.   (with-slots (normal-hints) shell
  521.     (when normal-hints
  522.       (wm-size-hints-user-specified-size-p normal-hints))))
  523.  
  524. (defmethod (setf wm-user-specified-size-p) (value (shell wm-shell))
  525.   (with-slots (normal-hints) shell
  526.     (unless normal-hints
  527.       (setf normal-hints (make-wm-size-hints)))
  528.     (setf (wm-size-hints-user-specified-size-p normal-hints) value))
  529.   (wm-update-normal-hints shell))
  530.  
  531. (defmethod wm-user-specified-position-p ((shell wm-shell))
  532.   (with-slots (normal-hints) shell
  533.     (when normal-hints
  534.       (wm-size-hints-user-specified-position-p normal-hints))))
  535.  
  536. (defmethod (setf wm-user-specified-position-p) (value (shell wm-shell))
  537.   (with-slots (normal-hints) shell
  538.     (unless normal-hints
  539.       (setf normal-hints (make-wm-size-hints)))
  540.     (setf (wm-size-hints-user-specified-position-p normal-hints) value))
  541.   (wm-update-normal-hints shell))
  542.  
  543. (defmethod wm-min-width ((shell wm-shell))
  544.   (with-slots (normal-hints) shell
  545.     (when normal-hints
  546.       (wm-size-hints-min-width normal-hints))))
  547.  
  548. (defmethod (setf wm-min-width) (value (shell wm-shell))
  549.   (with-slots (normal-hints) shell
  550.     (unless normal-hints
  551.       (setf normal-hints (make-wm-size-hints)))
  552.     (setf (wm-size-hints-min-width normal-hints) value))
  553.   (wm-update-normal-hints shell))
  554.  
  555. (defmethod wm-min-height ((shell wm-shell))
  556.   (with-slots (normal-hints) shell
  557.     (when normal-hints
  558.       (wm-size-hints-min-height normal-hints))))
  559.  
  560. (defmethod (setf wm-min-height) (value (shell wm-shell))
  561.   (with-slots (normal-hints) shell
  562.     (unless normal-hints
  563.       (setf normal-hints (make-wm-size-hints)))
  564.     (setf (wm-size-hints-min-height normal-hints) value))
  565.   (wm-update-normal-hints shell))
  566.  
  567. (defmethod wm-min-aspect ((shell wm-shell))
  568.   (with-slots (normal-hints) shell
  569.     (when normal-hints
  570.       (wm-size-hints-min-aspect normal-hints))))
  571.  
  572. (defmethod (setf wm-min-aspect) (value (shell wm-shell))
  573.   (with-slots (normal-hints) shell
  574.     (unless normal-hints
  575.       (setf normal-hints (make-wm-size-hints)))
  576.     (setf (wm-size-hints-min-aspect normal-hints) value))
  577.   (wm-update-normal-hints shell))
  578.  
  579. (defmethod wm-max-width ((shell wm-shell))
  580.   (with-slots (normal-hints) shell
  581.     (when normal-hints
  582.       (wm-size-hints-max-width normal-hints))))
  583.  
  584. (defmethod (setf wm-max-width) (value (shell wm-shell))
  585.   (with-slots (normal-hints) shell
  586.     (unless normal-hints
  587.       (setf normal-hints (make-wm-size-hints)))
  588.     (setf (wm-size-hints-max-width normal-hints) value))
  589.   (wm-update-normal-hints shell))
  590.  
  591. (defmethod wm-max-height ((shell wm-shell))
  592.   (with-slots (normal-hints) shell
  593.     (when normal-hints
  594.       (wm-size-hints-max-height normal-hints))))
  595.  
  596. (defmethod (setf wm-max-height) (value (shell wm-shell))
  597.   (with-slots (normal-hints) shell
  598.     (unless normal-hints
  599.       (setf normal-hints (make-wm-size-hints)))
  600.     (setf (wm-size-hints-max-height normal-hints) value))
  601.   (wm-update-normal-hints shell))
  602.  
  603. (defmethod wm-max-aspect ((shell wm-shell))
  604.   (with-slots (normal-hints) shell
  605.     (when normal-hints
  606.       (wm-size-hints-max-aspect normal-hints))))
  607.  
  608. (defmethod (setf wm-max-aspect) (value (shell wm-shell))
  609.   (with-slots (normal-hints) shell
  610.     (unless normal-hints
  611.       (setf normal-hints (make-wm-size-hints)))
  612.     (setf (wm-size-hints-max-aspect normal-hints) value))
  613.   (wm-update-normal-hints shell))
  614.  
  615. (defmethod wm-gravity ((shell wm-shell))
  616.   (with-slots (normal-hints) shell
  617.     (when normal-hints
  618.       (wm-size-hints-gravity normal-hints))))
  619.  
  620. (defmethod (setf wm-gravity) (value (shell wm-shell))
  621.   (with-slots (normal-hints) shell
  622.     (unless normal-hints
  623.       (setf normal-hints (make-wm-size-hints)))
  624.     (setf (wm-size-hints-gravity normal-hints) value))
  625.   (wm-update-normal-hints shell))
  626.  
  627. (defmethod wm-delta-width ((shell wm-shell))
  628.   (with-slots (normal-hints) shell
  629.     (when normal-hints
  630.       (wm-size-hints-width-inc normal-hints))))
  631.  
  632. (defmethod (setf wm-delta-width) (value (shell wm-shell))
  633.   (with-slots (normal-hints) shell
  634.     (unless normal-hints
  635.       (setf normal-hints (make-wm-size-hints)))
  636.     (setf (wm-size-hints-width-inc normal-hints) value))
  637.   (wm-update-normal-hints shell))
  638.  
  639. (defmethod wm-delta-height ((shell wm-shell))
  640.   (with-slots (normal-hints) shell
  641.     (when normal-hints
  642.       (wm-size-hints-height-inc normal-hints))))
  643.  
  644. (defmethod (setf wm-delta-height) (value (shell wm-shell))
  645.   (with-slots (normal-hints) shell
  646.     (unless normal-hints
  647.       (setf normal-hints (make-wm-size-hints)))
  648.     (setf (wm-size-hints-height-inc normal-hints) value))
  649.   (wm-update-normal-hints shell))
  650.  
  651. (defmethod wm-base-width ((shell wm-shell))
  652.   (with-slots (normal-hints) shell
  653.     (when normal-hints
  654.       (wm-size-hints-base-width normal-hints))))
  655.  
  656. (defmethod (setf wm-base-width) (value (shell wm-shell))
  657.   (with-slots (normal-hints) shell
  658.     (unless normal-hints
  659.       (setf normal-hints (make-wm-size-hints)))
  660.     (setf (wm-size-hints-base-width normal-hints) value))
  661.   (wm-update-normal-hints shell))
  662.  
  663. (defmethod wm-base-height ((shell wm-shell))
  664.   (with-slots (normal-hints) shell
  665.     (when normal-hints
  666.       (wm-size-hints-base-height normal-hints))))
  667.  
  668. (defmethod (setf wm-base-height) (value (shell wm-shell))
  669.   (with-slots (normal-hints) shell
  670.     (unless normal-hints
  671.       (setf normal-hints (make-wm-size-hints)))
  672.     (setf (wm-size-hints-base-height normal-hints) value))
  673.   (wm-update-normal-hints shell))
  674.  
  675.  
  676.  
  677.  
  678. ;;;----------------------------------------------------------------------------+
  679. ;;;                                                                            |
  680. ;;;              WM_HINTS accessors for wm-shell                       |
  681. ;;;                                                                            |
  682. ;;;----------------------------------------------------------------------------+
  683.  
  684. (defmethod (setf shell-hints) :after (new-hints (shell wm-shell))
  685.   (declare (ignore new-hints))
  686.   (wm-change-hints shell))
  687.  
  688. (defmethod wm-change-hints ((shell wm-shell))
  689.   "Send a request to change the WM_HINTS property for the SHELL."
  690.   (with-slots (hints) shell
  691.     (if hints
  692.     (setf (wm-hints shell) hints)
  693.     (delete-property shell :wm_hints))))
  694.  
  695. (defun wm-update-hints (shell)
  696.   "Record an update to the WM_HINTS property for the SHELL."
  697.   (if (wm-changing-properties-p shell)
  698.       (adjoin 'hints (wm-properties-changed shell))
  699.       (wm-change-hints shell)))
  700.  
  701. (defmethod wm-group ((shell wm-shell))
  702.   (with-slots (hints) shell
  703.     (when hints
  704.       (wm-hints-window-group hints))))
  705.  
  706. (defmethod (setf wm-group) (value (shell wm-shell))
  707.   (with-slots (hints) shell
  708.     (unless hints
  709.       (setf hints (make-wm-hints)))
  710.     (setf (wm-hints-window-group hints) value))
  711.   (wm-update-hints shell))
  712.  
  713. (defmethod wm-keyboard-input ((shell wm-shell))
  714.   (with-slots (hints) shell
  715.     (when hints
  716.       (wm-hints-input hints))))
  717.  
  718. (defmethod (setf wm-keyboard-input) (value (shell wm-shell))
  719.   (with-slots (hints) shell
  720.     (unless hints
  721.       (setf hints (make-wm-hints)))
  722.     (setf (wm-hints-input hints) value))
  723.   (wm-update-hints shell))
  724.  
  725. (defmethod wm-initial-state ((shell wm-shell))
  726.   (with-slots (hints) shell
  727.     (when hints
  728.       (wm-hints-initial-state hints))))
  729.  
  730. (defmethod (setf wm-initial-state) (value (shell wm-shell))
  731.   (with-slots (hints) shell
  732.     (unless hints
  733.       (setf hints (make-wm-hints)))
  734.     (setf (wm-hints-state hints) value))
  735.   (wm-update-hints shell))
  736.  
  737.  
  738.  
  739. ;;;----------------------------------------------------------------------------+
  740. ;;;                                                                            |
  741. ;;;                :client-message translations                        |
  742. ;;;                                                                            |
  743. ;;;----------------------------------------------------------------------------+
  744.  
  745. (defstruct (wm-message (:type (vector int32)))
  746.   "Common data fields of all :client-message events from a window/session mgr." 
  747.   protocol
  748.   timestamp)
  749.  
  750. (defun wm-message-protocol-atom (wm-message)
  751.   (declare (special *event-display*))
  752.   (atom-name *event-display* (wm-message-protocol wm-message)))
  753.  
  754. (defevent wm-shell (:wm_take_focus) wm-take-focus)
  755.  
  756. (defmethod wm-take-focus ((shell wm-shell))
  757.   (with-slots (children) shell
  758.     (when children
  759.       (wm-take-focus (first children)))))
  760.  
  761. (defmethod wm-take-focus ((composite composite))
  762.   (with-slots (display) composite
  763.     (if (accept-focus-p composite)
  764.     (set-input-focus display composite :parent)
  765.     (move-focus composite :set))))
  766.  
  767. (defmethod wm-take-focus ((contact contact))
  768.   (with-slots (display) contact
  769.     (when (accept-focus-p contact)
  770.       (set-input-focus display contact :parent))))
  771.  
  772.  
  773.  
  774. ;;;----------------------------------------------------------------------------+
  775. ;;;                                                                            |
  776. ;;;                 Transient Shells                               |
  777. ;;;                                                                            |
  778. ;;;----------------------------------------------------------------------------+
  779.  
  780.  
  781.  
  782. (defcontact transient-shell (wm-shell)
  783.   ()  
  784.   (:documentation
  785.     "Base class for shells which are never iconified."))
  786.  
  787. (defmethod realize :after ((shell transient-shell)) 
  788.   (wm-change-transient-for shell))
  789.  
  790. ;; This should only be called during initialization
  791. (defmethod wm-change-transient-for ((shell transient-shell))
  792.   "Send a request to change the TRANSIENT-FOR property for the SHELL."
  793.   (with-slots (owner) shell
  794.     (setf (transient-for shell) owner)))
  795.  
  796.  
  797.  
  798.  
  799.  
  800. ;;;----------------------------------------------------------------------------+
  801. ;;;                                                                            |
  802. ;;;                 Top-Level Shells                               |
  803. ;;;                                                                            |
  804. ;;;----------------------------------------------------------------------------+
  805.  
  806.  
  807. (defcontact top-level-shell (wm-shell)
  808.   ((colormap-owners      :type     list
  809.              :initform nil 
  810.              :initarg  :colormap-owners
  811.              :accessor wm-colormap-owners)
  812.    
  813.    (icon                 :type     (or null drawable)
  814.              :initform nil 
  815.              :initarg  :icon
  816.              :accessor wm-icon)
  817.    
  818.    (icon-mask            :type     (or null pixmap)
  819.              :initform nil 
  820.              :initarg  :icon-mask
  821.              :accessor wm-icon-mask)
  822.    
  823.    (icon-title           :type     (or null stringable)
  824.              :initform nil 
  825.              :initarg  :icon-title
  826.              :accessor wm-icon-title)
  827.    
  828.    (icon-x               :type     (or null int16)
  829.              :initform nil 
  830.              :initarg  :icon-x
  831.              :accessor wm-icon-x)
  832.    
  833.    (icon-y               :type     (or null int16)
  834.              :initform nil 
  835.              :initarg  :icon-y
  836.              :accessor wm-icon-y))
  837.   
  838.   (:documentation
  839.     "Base class for normal top-level shells."))
  840.  
  841. (defmethod realize :after ((shell top-level-shell)) 
  842.   (wm-change-colormap-windows shell) 
  843.   (wm-change-icon-name        shell))
  844.  
  845.  
  846. ;;;----------------------------------------------------------------------------+
  847. ;;;                                                                            |
  848. ;;;               WM_COLORMAP_WINDOWS accessors                        |
  849. ;;;                                                                            |
  850. ;;;----------------------------------------------------------------------------+
  851.  
  852. (defmethod (setf wm-colormap-owners) :after (new-colormap-owners (shell top-level-shell))
  853.   (declare (ignore new-colormap-owners))
  854.   (if (wm-changing-properties-p shell)
  855.       (adjoin 'colormap-windows (wm-properties-changed shell))
  856.       (wm-change-colormap-windows shell)))
  857.  
  858. (defmethod wm-change-colormap-windows ((shell top-level-shell))
  859.   "Send a request to change the COLORMAP-WINDOWS property for the SHELL."
  860.   (with-slots (colormap-owners) shell
  861.     (if colormap-owners
  862.     (change-property shell :wm_colormap_windows
  863.              colormap-owners
  864.              :window
  865.              32
  866.              :transform #'window-id)
  867.     (delete-property shell :wm_colormap_windows))))
  868.  
  869.  
  870. ;;;----------------------------------------------------------------------------+
  871. ;;;                                                                            |
  872. ;;;                  WM_ICON_NAME accessors                            |
  873. ;;;                                                                            |
  874. ;;;----------------------------------------------------------------------------+
  875.  
  876.  
  877. (defmethod (setf wm-icon-title) :after (new-icon-title (shell top-level-shell))
  878.   (declare (ignore new-icon-title))
  879.   (if (wm-changing-properties-p shell)
  880.       (adjoin 'icon-name (wm-properties-changed shell))
  881.       (wm-change-icon-name shell)))
  882.  
  883. (defmethod wm-change-icon-name ((shell top-level-shell))
  884.   "Send a request to change the WM_ICON_NAME property for the SHELL."
  885.   (with-slots (icon-title) shell
  886.     (if icon-title
  887.     (setf (wm-icon-name shell) icon-title)
  888.     (delete-property shell :wm_icon_name))))
  889.  
  890.  
  891. ;;;----------------------------------------------------------------------------+
  892. ;;;                                                                            |
  893. ;;;              WM_HINTS accessors for top-level-shell                |
  894. ;;;                                                                            |
  895. ;;;----------------------------------------------------------------------------+
  896.  
  897.  
  898. (defmethod wm-icon ((shell top-level-shell))
  899.   (with-slots (hints) shell
  900.     (when hints
  901.       (or (wm-hints-icon-pixmap hints)
  902.       (wm-hints-icon-window hints)))))
  903.  
  904. (defmethod (setf wm-icon) ((value pixmap) (shell top-level-shell))
  905.   (with-slots (hints) shell
  906.     (unless hints
  907.       (setf hints (make-wm-hints)))
  908.     (setf (wm-hints-icon-pixmap hints) value
  909.       (wm-hints-icon-window hints) nil))
  910.   (wm-update-hints shell))
  911.  
  912. (defmethod (setf wm-icon) ((value window) (shell top-level-shell))
  913.   (with-slots (hints) shell
  914.     (unless hints
  915.       (setf hints (make-wm-hints)))
  916.     (setf (wm-hints-icon-window hints) value
  917.       (wm-hints-icon-pixmap hints) nil))
  918.   (wm-update-hints shell))
  919.  
  920. (defmethod wm-icon-mask ((shell top-level-shell))
  921.   (with-slots (hints) shell
  922.     (when hints
  923.       (wm-hints-icon-mask hints))))
  924.  
  925. (defmethod (setf wm-icon-mask) (value (shell top-level-shell))
  926.   (with-slots (hints) shell
  927.     (unless hints
  928.       (setf hints (make-wm-hints)))
  929.     (setf (wm-hints-icon-mask hints) value))
  930.   (wm-update-hints shell))
  931.  
  932.  
  933. (defmethod wm-icon-x ((shell top-level-shell))
  934.   (with-slots (hints) shell
  935.     (when hints
  936.       (wm-hints-icon-x hints))))
  937.  
  938. (defmethod (setf wm-icon-x) (value (shell top-level-shell))
  939.   (with-slots (hints) shell
  940.     (unless hints
  941.       (setf hints (make-wm-hints)))
  942.     (setf (wm-hints-icon-x hints) value))
  943.   (wm-update-hints shell))
  944.  
  945.  
  946. (defmethod wm-icon-y ((shell top-level-shell))
  947.   (with-slots (hints) shell
  948.     (when hints
  949.       (wm-hints-icon-y hints))))
  950.  
  951. (defmethod (setf wm-icon-y) (value (shell top-level-shell))
  952.   (with-slots (hints) shell
  953.     (unless hints
  954.       (setf hints (make-wm-hints)))
  955.     (setf (wm-hints-icon-y hints) value))
  956.   (wm-update-hints shell))
  957.  
  958.  
  959.  
  960.  
  961. ;;;----------------------------------------------------------------------------+
  962. ;;;                                                                            |
  963. ;;;                 Top-Level Session Shells                           |
  964. ;;;                                                                            |
  965. ;;;----------------------------------------------------------------------------+
  966.  
  967.  
  968. (defcontact top-level-session (top-level-shell)
  969.   ((client-host          :type     (or null stringable)
  970.              :initform nil 
  971.              :initarg  :client-host
  972.              :accessor sm-client-host)
  973.  
  974.    (command              :type     (or null string)
  975.              :initform nil 
  976.              :initarg  :command
  977.              :accessor sm-command))  
  978.   (:documentation
  979.     "Base class for top-level shells that communicate with a session manager."))
  980.  
  981.  
  982. ;;;----------------------------------------------------------------------------+
  983. ;;;                                                                            |
  984. ;;;                  WM_CLIENT_MACHINE accessors                       |
  985. ;;;                                                                            |
  986. ;;;----------------------------------------------------------------------------+
  987.  
  988.  
  989. (defmethod (setf sm-client-host) :after (new-client-host (shell top-level-session))
  990.   (declare (ignore new-client-host))
  991.   (if (wm-changing-properties-p shell)
  992.       (adjoin 'client-machine (wm-properties-changed shell))
  993.       (wm-change-client-machine  shell)))
  994.  
  995. (defmethod wm-change-client-machine  ((shell top-level-session))
  996.   "Send a request to change the WM_CLIENT_MACHINE property for the SHELL."
  997.   (with-slots (client-host) shell
  998.     (if client-host
  999.     (setf (wm-client-machine shell) client-host)
  1000.     (delete-property shell :wm_client_machine))))
  1001.  
  1002.  
  1003. ;;;----------------------------------------------------------------------------+
  1004. ;;;                                                                            |
  1005. ;;;                  WM_COMMAND accessors                              |
  1006. ;;;                                                                            |
  1007. ;;;----------------------------------------------------------------------------+
  1008.  
  1009.  
  1010. (defmethod (setf sm-command) :after (new-command (shell top-level-session))
  1011.   (declare (ignore new-command))
  1012.   (if (wm-changing-properties-p shell)
  1013.       (adjoin 'command (wm-properties-changed shell))
  1014.       (wm-change-command shell)))
  1015.  
  1016. (defmethod wm-change-command ((shell top-level-session))
  1017.   "Send a request to change the WM_COMMAND property for the SHELL."
  1018.   (with-slots (command) shell
  1019.     (if command
  1020.     (setf (wm-command shell) command)
  1021.     (delete-property shell :wm_command))))
  1022.  
  1023.